;; (require :kmrcl)
(in-package "MAXIMA")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Preferences

(defparameter *port* 9893
  "What port to listen on")

(defparameter *timeout* 10
  "How many seconds to wait before timing out, or nil for no timeout")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defparameter *listener* nil
  "The KMRCL listener for simple-server")

(defparameter *networked-p* nil
  "Are we networked right now?")

(defparameter *command-alist* '((eval . maxima-server-eval)
				(eval-safe . maxima-server-eval-safe)
				(displa1d . maxima-server-displa1d)
				(parse . maxima-server-parse)
				(displa . maxima-server-displa))
  "Alist mapping command names to the functions that actually carry
them out")

(defun maxima-repr (expr)
  "Return a 1D representation of a Maxima sexp"
  (let ((string (with-output-to-string (*standard-output*)
		  (let (($display2d nil))
		    (displa expr)))))
    (subseq string 0 (1- (length string)))))

(defun maxima-server-eval-aux (string &optional (safe-p t))
  "Evaluate a Maxima string, optionally doing some safety checking first"
  (if (when safe-p (dangerous-p string))
      "ERROR: Query not allowed"
      (let ((string-to-read (format nil "#$ ~A $" string)))
	(maxima-repr (eval (read-from-string string-to-read nil nil))))))

(defun maxima-server-eval (string)
  "Server command: Evaluate a Maxima string unsafely"
  (maxima-server-eval-aux string nil))

(defun maxima-server-eval-safe (string)
  "Server command: Evaluate a Maxima string semi-safely"
  (maxima-server-eval-aux string t))

(defun dangerous-p (string)
  "Is a query dangerous?"
  (let ((upcased-string (string-upcase string))
	(string-length (length string)))
    (some #'identity
	  (mapcar #'(lambda (pattern)
		      (kmrcl:fast-string-search pattern upcased-string
						(length pattern) 0
						string-length))
		  '("$" "?" "ALARMCLOCK" "ALIAS" "ALIASES" "ALLOC" "ALPHABETIC" "APPENDFILE" "APROPOS" "BACKTRACE" "BACKUP" "BATCH" "BATCHKILL" "BATCHLOAD" "BATCON" "BATCOUNT" "BOX" "BOXCHAR" "BREAK" "BUG" "BUG_REPORT" "BUILD_INDO" "BUILDQ" "CATCH" "CHANGE_FILEDEFAULTS" "CLEARSCREEN" "CLOSEFILE" "CLOSEPS" "COMPFILE" "COMPGRIND" "COMPILE" "COMPILE_FILE" "COMPILE_LISP_FILE" "CONTINUE" "CURRENT_LET_RULE_PACKAGE" "CURSORDISP" "DDT" "DEACTIVATE" "DEBUG" "DEBUGMODE" "DEBUGPRINTMODE" "DEFINE" "DEFINE_VARIABLE" "DELFILE" "DEMO" "DEPENDENCIES" "DESCRIBE" "DIREC" "DISKFREE" "DSKALL" "DUMMY" "ERRCATCH" "ERREXP" "ERROR" "ERROR_SIZE" "ERROR_SYMS" "ERRORFUN" "ERRORMSG" "EXAMPLE" "FASSAVE" "FEATURE" "FEATUREP" "FEATURES" "FILE_SEARCH" "FILE_STRING_PRINT" "FILE_TYPE" "FILEDEFAULTS" "FILENAME" "FILENAME_MERGE" "FILENUM" "FORTINDENT" "FORTMX" "FORTRAN" "FORTSPACES" "FUNCTIONS" "FUNDEF" "FUNMAKE" "INCHAR" "INFEVAL" "INFOLISTS" "KILL" "KILLCONTEXT" "LABELS" "LDISP" "LDISPLAY" "LINECHAR" "LINEDISP" "LINEL" "LINENUM" "LINSOLVEWARN" "LISPDEBUGMODE" "LMXCHAR" "LOAD" "LOADFILE" "LOADPRINT" "MACROEXPANSION" "MYOPTIONS" "NOLABELS" "NOSTRING" "OUTCHAR" "PACKAGEFILE" "PARSEWINDOW" "PICKAPART" "PIECE" "PLAYBACK" "PROMPT" "QUIT" "READ" "READONLY" "REFCHECK" "REMBOX" "REMFUNCTION" "REMTRACE" "RESET" "RESTORE" "RMXCHAR" "ROOM" "run_testsuite" "SAVE" "SAVEDEF" "SET_PLOT_OPTION" "SETCHECK" "SETCHECKBREAK" "SETVAL" "SHOWTIME" "SPLICE" "SPRINT" "STATUS" "STRINGOUT" "SUPCONTEXT" "SYSTEM" "TCL_OUTPUT" "THROW" "TIME" "TIMER" "TIMER_DEVALUE" "TIMER_INFO" "TO_LISP" "TOBREAK" "TOPLEVEL" "TRACE" "TRACE_OPTIONS" "TRANSBIND" "TRANSCOMPILE" "TRANSLATE" "TRANSLATE_FILE" "TRANSRUN" "TTYINTFUN" "TTYINTNUM" "TTYOFF" "UNTRACE" "VALUES" "WITH_STDOUT" "WRITEFILE" "xgraph_curves" "?ROUND" "?TRUNCATE" "ABSBOXCHAR" "ACTIVATE" "ACTIVECONTEXTS" "ADDITIVE" "ALL_DOTSIMP_DENOMS" "ANTID" "ANTIDIFF" "ANTISYMMETRIC" "ARRAY" "ARRAYAPPLY" "ARRAYINFO" "ARRAYMAKE" "ARRAYS" "ASSOC_LEGENDRE_P" "ASSOC_LEGENDRE_Q" "ASYMP" "ASYMPA" "ATOMGRAD" "ATRIG1" "ATVALUE" "AUGCOEFMATRIX" "BACKSUBST" "BASHINDICES" "BERLEFACT" "BFPSI" "BINDTEST" "BUILD_INFO" "CANFORM" "CANTEN" "CARG" "CHECK_OVERLAPS" "CHR1" "CHR2" "CHRISTOF" "COLLAPSE" "COMP2PUI" "CONT2PART" "CONTEXT" "CONTEXTS" "COUNTER" "COVDIFF" "CREATE_LIST" "CURVATURE" "DECLARE_TRANSLATED" "DECLARE_WEIGHT" "DEFAULT_LET_RULE_PACKAGE" "DEFCON" "DEFMATCH" "DEFRULE" "DIAGMETRIC" "DIM" "DIMENSION" "DIRECT" "DISP" "DISPCON" "DISPFLAG" "DISPFORM" "DISPFUN" "DISPLAY" "DISPLAY2D" "DISPLAY_FORMAT_INTERNAL" "DISPRULE" "DISPTERMS" "DISTRIB" "DOMXEXPT" "DOMXMXOPS" "DOMXNCTIMES" "DOTSIMP" "EINSTEIN" "ELE2COMP" "ELE2POLYNOME" "ELE2PUI" "ELEM" "ENTERMATRIX" "ENTIER" "ERRINTSCE" "EVFLAG" "EVFUN" "EXPLOSE" "EXPON" "EXPOP" "EXPT" "EXTRACT_LINEAR_EQUATIONS" "FACTS" "FAST_CENTRAL_ELEMENTS" "FAST_LINSOLVE" "FILLARRAY" "FIX" "FLOATDEFUNK" "FLUSH" "FLUSHD" "FLUSHND" "FORGET" "GAUSS" "GENSUMNUM" "GET" "GETCHAR" "GLOBALSOLVE" "GRADEF" "GRADEFS" "GROBNER_BASIS" "HACH" "IEQN" "IEQNPRINT" "IN_NETMATH" "INDICES" "INFIX" "INTEGRATE_USE_ROOTSOF" "INTEGRATION_CONSTANT_COUNTER" "INTOPOIS" "INTPOLERROR" "INTPOLREL" "ISOLATE" "ISOLATE_WRT_TIMES" "KDELTA" "KOSTKA" "LASSOCIATIVE" "LC" "LET" "LET_RULE_PACKAGES" "LETRAT" "LETRULES" "LETSIMP" "LGTREILLIS" "LIST_NC_MONOMIALS" "LISTARRAY" "LORENTZ" "LPART" "LRICCICOM" "LTREILLIS" "M1PBRANCH" "MAINVAR" "MAKE_ARRAY" "MAKEBOX" "MAPERROR" "MAXAPPLYDEPTH" "MAXAPPLYHEIGHT" "MAXNEGEX" "MAXPOSEX" "MAXPRIME" "MAXTAYORDER" "METRIC" "MINOR" "MODE_CHECK_ERRORP" "MODE_CHECK_WARNP" "MODE_CHECKP" "MODE_DECLARE" "MODE_IDENTITY" "MON2SCHUR" "MONO" "MONOMIAL_DIMENSIONS" "MOTION" "MULTI_ELEM" "MULTI_ORBIT" "MULTI_PUI" "MULTINOMIAL" "MULTSYM" "NC_DEGREE" "NEW-DISREP" "NEWCONTEXT" "NEWFAC" "NEWTON" "NEXTLAYERFACTOR" "NICEINDICES" "NICEINDICESPREF" "NOUNDISP" "NTERMSG" "NTERMSRCI" "NZETA" "ODE" "ODE2" "OMEGA" "OPENPLOT_CURVES" "OPTIMIZE" "OPTIMPREFIX" "OPTIONSET" "ORBIT" "OUTOFPOIS" "PARTPOL" "PCOEFF" "PERMUT" "PLOT2D" "PLOT2D_PS" "PLOT3D" "PLOT_OPTIONS" "PREDERROR" "PRIME" "PRINTPROPS" "PRODHACK" "PRODRAC" "PRODUCT" "PROGRAMMODE" "PROPS" "PROPVARS" "PSCOM" "PSDRAW_CURVE" "PSEXPAND" "PUI" "PUI2COMP" "PUI2ELE" "PUI2POLYNOME" "PUI_DIRECT" "PUIREDUC" "QQ" "RAISERIEMANN" "RANDOM" "RATPRINT" "RATRIEMAN" "RATRIEMANN" "RATWEYL" "RATWTLVL" "REARRAY" "REMARRAY" "REMCON" "REMLET" "RESOLVANTE" "RESOLVANTE_ALTERNEE1" "RESOLVANTE_BIPARTITE" "RESOLVANTE_DIEDRALE" "RESOLVANTE_KLEIN" "RESOLVANTE_KLEIN3" "RESOLVANTE_PRODUIT_SYM" "RESOLVANTE_UNITAIRE" "RESOLVANTE_VIERER" "REVERT" "RICCICOM" "RIEMANN" "RINVARIANT" "SAVEFACTORS" "SCALEFACTORS" "SET_UP_DOT_SIMPLIFICATIONS" "SETELMX" "SETUP" "SETUP_AUTOLOAD" "SIMILARITYTRANSFORM" "SOMRAC" "SSTATUS" "STARDISP" "TCONTRACT" "TOTALDISREP" "TOTIENT" "TPARTPOL" "TR_ARRAY_AS_REF" "TR_BOUND_FUNCTION_APPLYP" "TR_FILE_TTY_MESSAGESP" "TR_FLOAT_CAN_BRANCH_COMPLEX" "TR_FUNCTION_CALL_DEFAULT" "TR_GEN_TAGS" "TR_NUMER" "TR_OPTIMIZE_MAX_LOOP" "TR_OUTPUT_FILE_DEFAULT" "TR_PREDICATE_BRAIN_DAMAGE" "TR_SEMICOMPILE" "TR_STATE_VARS" "TR_TRUE_NAME_OF_FILE_BEING_TRANSLATED" "TR_VERSION" "TR_WARN_BAD_FUNCTION_CALLS" "TR_WARN_FEXPR" "TR_WARN_MEVAL" "TR_WARN_MODE" "TR_WARN_UNDECLARED" "TR_WARN_UNDEFINED_VARIABLE" "TR_WARNINGS_GET" "TR_WINDY" "TRANSFORM" "TREILLIS" "TREINAT" "TSETUP" "TTRANSFORM" "ULTRASPHERICAL" "UNDECLAREDWARN" "UNDIFF" "UNITEIGENVECTORS" "UNITVECTOR" "UNKNOWN" "UNORDER" "USE_FAST_ARRAYS" "VERBOSE" "WEYL" "ZRPOLY" "ZSOLVE" "ZUNDERFLOW")))))

(defun maxima-server-displa1d (string)
  "Server command: parse a sexp, return a 1D display of it"
  (let ((sexp (let ((*read-eval* nil))
		(read-from-string string nil nil))))
    (maxima-repr sexp)))

(defun maxima-server-displa (string)
  "Server command: parse a sexp, return a 2D display of it"
  (let* ((sexp (let ((*read-eval* nil))
		(read-from-string string nil nil)))
	 (outstring (with-output-to-string (stream)
		      (displaf sexp stream))))
    (subseq outstring 0 (1- (length outstring)))))

(defun maxima-server-parse (string)
  "Server command: parse a string in Maxima syntax and return a sexp
representation of it"
  (let ((string-to-read (format nil "#$ ~A $" string)))
    (cadadr (read-from-string string-to-read nil nil))))

(defun maxima-listen (stream)
  "Connection-specific listener function. This is called in a new
thread to deal with each incoming request."
  (let* ((*networked-p* t)
	 (command (let ((*read-eval* nil))
		    (read stream nil nil)))
	 (command-function (cdr (assoc (car command)
				       *command-alist*)))
	 (output (catch 'return-to-client
		   (handler-case (apply command-function (cdr command))
		     (error (e) (format nil "ERROR: ~S" e))))))
    (princ output stream)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun retrieve (msg flag &aux (print? nil))
  (declare (special msg flag print?))
  (or (eq flag 'noprint) (setq print? t))
  (handler-case (throw 'return-to-client
		  (format nil "ERROR: ~S"
			  (funcall #'maxima-repr msg)))
    (error ()
      (cond ((not print?) 
	     (setq print? t)
	     (princ *prompt-prefix*)
	     (princ *prompt-suffix*))
	    ((null msg)
	     (princ *prompt-prefix*)
	     (princ *prompt-suffix*))
	    ((atom msg) 
	     (format t "~a~a~a" *prompt-prefix* msg *prompt-suffix*)
	     (mterpri))
	    ((eq flag t)
	     (princ *prompt-prefix*) 
	     (mapc #'princ (cdr msg)) 
	     (princ *prompt-suffix*)
	     (mterpri))
	    (t 
	     (princ *prompt-prefix*)
	     (displa msg) 
	     (princ *prompt-suffix*)
	     (mterpri)))
      (mread-noprompt *query-io* nil))))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (let ((oldfunc #'mread-synerr))
    (defun mread-synerr (sstring &rest l)
      (if *networked-p*
	  (throw 'return-to-client
	    (format nil "ERROR: ~S"
		    (with-output-to-string (*standard-output*)
		      (apply oldfunc sstring l))))
	  (apply oldfunc sstring l)))))

(defun start-simple-server ()
  (if *listener*
      (warn "Simple server is already running")
      (progn
	(setf *listener* (make-instance 'kmrcl:listener
					:port *port*
					:base-name "simple-maxima-server"
					:function 'maxima-listen
					:format :text
					:wait nil
					:catch-errors t
					:timeout nil;*timeout*
					:number-fixed-workers nil
					:remote-host-checker nil))
	(kmrcl:init/listener *listener* :start))))

(defun stop-simple-server ()
  (if *listener*
      (progn
	(kmrcl:init/listener *listener* :stop)
	(setf *listener* nil))
      (warn "Simple server is not running")))